home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / pop3.el.z / pop3.el
Encoding:
Text File  |  1998-05-21  |  14.2 KB  |  463 lines
  1. ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
  2.  
  3. ;; Copyright (C) 1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
  6. ;; Keywords: mail, pop3
  7. ;; Version: 1.3g
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
  29. ;; are implemented.  The LIST command has not been implemented due to lack
  30. ;; of actual usefulness.
  31. ;; The optional POP3 command TOP has not been implemented.
  32.  
  33. ;; This program was inspired by Kyle E. Jones's vm-pop program.
  34.  
  35. ;;; Code:
  36.  
  37. (require 'mail-utils)
  38. (provide 'pop3)
  39.  
  40. (defconst pop3-version "1.3g")
  41.  
  42. (defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil)
  43.   "*POP3 maildrop.")
  44. (defvar pop3-mailhost (or (getenv "MAILHOST") nil)
  45.   "*POP3 mailhost.")
  46. (defvar pop3-port 110
  47.   "*POP3 port.")
  48.  
  49. (defvar pop3-password-required t
  50.   "*Non-nil if a password is required when connecting to POP server.")
  51. (defvar pop3-password nil
  52.   "*Password to use when connecting to POP server.")
  53.  
  54. (defvar pop3-authentication-scheme 'pass
  55.   "*POP3 authentication scheme.
  56. Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
  57. values are 'apop.")
  58.  
  59. (defvar pop3-timestamp nil
  60.   "Timestamp returned when initially connected to the POP server.
  61. Used for APOP authentication.")
  62.  
  63. (defvar pop3-movemail-file-coding-system nil
  64.   "Crashbox made by pop3-movemail with this coding system.")
  65.  
  66. (defvar pop3-read-point nil)
  67. (defvar pop3-debug nil)
  68.  
  69. (defun pop3-movemail (&optional crashbox)
  70.   "Transfer contents of a maildrop to the specified CRASHBOX."
  71.   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
  72.   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
  73.      (crashbuf (get-buffer-create " *pop3-retr*"))
  74.      (n 1)
  75.      message-count)
  76.     ;; for debugging only
  77.     (if pop3-debug (switch-to-buffer (process-buffer process)))
  78.     (cond ((equal 'apop pop3-authentication-scheme)
  79.        (pop3-apop process pop3-maildrop))
  80.       ((equal 'pass pop3-authentication-scheme)
  81.        (pop3-user process pop3-maildrop)
  82.        (pop3-pass process))
  83.       (t (error "Invalid POP3 authentication scheme.")))
  84.     (setq message-count (car (pop3-stat process)))
  85.     (while (<= n message-count)
  86.       (message (format "Retrieving message %d of %d from %s..."
  87.                n message-count pop3-mailhost))
  88.       (pop3-retr process n crashbuf)
  89.       (save-excursion
  90.     (set-buffer crashbuf)
  91.     (let ((coding-system-for-write pop3-movemail-file-coding-system))
  92.       (append-to-file (point-min) (point-max) crashbox))
  93.     (set-buffer (process-buffer process))
  94.     (while (> (buffer-size) 5000)
  95.       (goto-char (point-min))
  96.       (forward-line 50)
  97.       (delete-region (point-min) (point))))
  98.       (pop3-dele process n)
  99.       (setq n (+ 1 n))
  100.       (if pop3-debug (sit-for 1) (sit-for 0.1))
  101.       )
  102.     (pop3-quit process)
  103.     (kill-buffer crashbuf)
  104.     )
  105.   )
  106.  
  107. (defun pop3-open-server (mailhost port)
  108.   "Open TCP connection to MAILHOST.
  109. Returns the process associated with the connection."
  110.   (let ((process-buffer
  111.      (get-buffer-create (format "trace of POP session to %s" mailhost)))
  112.     (process))
  113.     (save-excursion
  114.       (set-buffer process-buffer)
  115.       (erase-buffer))
  116.     (setq process
  117.       (open-network-stream "POP" process-buffer mailhost port))
  118.     (setq pop3-read-point (point-min))
  119.     (let ((response (pop3-read-response process t)))
  120.       (setq pop3-timestamp
  121.         (substring response (or (string-match "<" response) 0)
  122.                (+ 1 (or (string-match ">" response) -1)))))
  123.     process
  124.     ))
  125.  
  126. ;; Support functions
  127.  
  128. (defun pop3-process-filter (process output)
  129.   (save-excursion
  130.     (set-buffer (process-buffer process))
  131.     (goto-char (point-max))
  132.     (insert output)))
  133.  
  134. (defun pop3-send-command (process command)
  135.     (set-buffer (process-buffer process))
  136.     (goto-char (point-max))
  137. ;;    (if (= (aref command 0) ?P)
  138. ;;    (insert "PASS <omitted>\r\n")
  139. ;;      (insert command "\r\n"))
  140.     (setq pop3-read-point (point))
  141.     (goto-char (point-max))
  142.     (process-send-string process command)
  143.     (process-send-string process "\r\n")
  144.     )
  145.  
  146. (defun pop3-read-response (process &optional return)
  147.   "Read the response from the server.
  148. Return the response string if optional second argument is non-nil."
  149.   (let ((case-fold-search nil)
  150.     match-end)
  151.     (save-excursion
  152.       (set-buffer (process-buffer process))
  153.       (goto-char pop3-read-point)
  154.       (while (not (search-forward "\r\n" nil t))
  155.     (accept-process-output process 3)
  156.     (goto-char pop3-read-point))
  157.       (setq match-end (point))
  158.       (goto-char pop3-read-point)
  159.       (if (looking-at "-ERR")
  160.       (error (buffer-substring (point) (- match-end 2)))
  161.     (if (not (looking-at "+OK"))
  162.         (progn (setq pop3-read-point match-end) nil)
  163.       (setq pop3-read-point match-end)
  164.       (if return
  165.           (buffer-substring (point) match-end)
  166.         t)
  167.       )))))
  168.  
  169. (defun pop3-string-to-list (string &optional regexp)
  170.   "Chop up a string into a list."
  171.   (let ((list)
  172.     (regexp (or regexp " "))
  173.     (string (if (string-match "\r" string)
  174.             (substring string 0 (match-beginning 0))
  175.           string)))
  176.     (store-match-data nil)
  177.     (while string
  178.       (if (string-match regexp string)
  179.       (setq list (cons (substring string 0 (- (match-end 0) 1)) list)
  180.         string (substring string (match-end 0)))
  181.     (setq list (cons string list)
  182.           string nil)))
  183.     (nreverse list)))
  184.  
  185. (defvar pop3-read-passwd nil)
  186. (defun pop3-read-passwd (prompt)
  187.   (if (not pop3-read-passwd)
  188.       (if (load "passwd" t)
  189.       (setq pop3-read-passwd 'read-passwd)
  190.     (autoload 'ange-ftp-read-passwd "ange-ftp")
  191.     (setq pop3-read-passwd 'ange-ftp-read-passwd)))
  192.   (funcall pop3-read-passwd prompt))
  193.  
  194. (defun pop3-clean-region (start end)
  195.   (setq end (set-marker (make-marker) end))
  196.   (save-excursion
  197.     (goto-char start)
  198.     (while (and (< (point) end) (search-forward "\r\n" end t))
  199.       (replace-match "\n" t t))
  200.     (goto-char start)
  201.     (while (and (< (point) end) (re-search-forward "^\\." end t))
  202.       (replace-match "" t t)
  203.       (forward-char)))
  204.   (set-marker end nil))
  205.  
  206. (defun pop3-munge-message-separator (start end)
  207.   "Check to see if a message separator exists.  If not, generate one."
  208.   (if (not (fboundp 'message-make-date)) (autoload 'message-make-date "message"))
  209.   (save-excursion
  210.     (save-restriction
  211.       (narrow-to-region start end)
  212.       (goto-char (point-min))
  213.       (if (not (or (looking-at "From .?") ; Unix mail
  214.            (looking-at "\001\001\001\001\n") ; MMDF
  215.            (looking-at "BABYL OPTIONS:") ; Babyl
  216.            ))
  217.       (let ((from (mail-strip-quoted-names (mail-fetch-field "From")))
  218.         (date (pop3-string-to-list (or (mail-fetch-field "Date")
  219.                            (message-make-date))))
  220.         (From_))
  221.         ;; sample date formats I have seen
  222.         ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
  223.         ;; Date: 08 Jul 1996 23:22:24 -0400
  224.         ;; should be
  225.         ;; Tue Jul 9 09:04:21 1996
  226.         (setq date
  227.           (cond ((string-match "[A-Z]" (nth 0 date))
  228.              (format "%s %s %s %s %s"
  229.                  (nth 0 date) (nth 2 date) (nth 1 date)
  230.                  (nth 4 date) (nth 3 date)))
  231.             (t
  232.              ;; this really needs to be better but I don't feel
  233.              ;; like writing a date to day converter.
  234.              (format "Sun %s %s %s %s"
  235.                  (nth 1 date) (nth 0 date)
  236.                  (nth 3 date) (nth 2 date)))
  237.             ))
  238.         (setq From_ (format "\nFrom %s  %s\n" from date))
  239.         (while (string-match "," From_)
  240.           (setq From_ (concat (substring From_ 0 (match-beginning 0))
  241.                   (substring From_ (match-end 0)))))
  242.         (goto-char (point-min))
  243.         (insert From_))))))
  244.  
  245. ;; The Command Set
  246.  
  247. ;; AUTHORIZATION STATE
  248.  
  249. (defun pop3-user (process user)
  250.   "Send USER information to POP3 server."
  251.   (pop3-send-command process (format "USER %s" user))
  252.   (let ((response (pop3-read-response process t)))
  253.     (if (not (and response (string-match "+OK" response)))
  254.     (error (format "USER %s not valid." user)))))
  255.  
  256. (defun pop3-pass (process)
  257.   "Send authentication information to the server."
  258.   (let ((pass pop3-password))
  259.     (if (and pop3-password-required (not pass))
  260.     (setq pass
  261.           (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
  262.     (if pass
  263.     (progn
  264.       (pop3-send-command process (format "PASS %s" pass))
  265.       (let ((response (pop3-read-response process t)))
  266.         (if (not (and response (string-match "+OK" response)))
  267.         (pop3-quit process)))))
  268.     ))
  269.  
  270. (defvar pop3-md5-program "md5"
  271.   "*Program to encode its input in MD5.")
  272.  
  273. (defun pop3-md5 (string)
  274.   (with-temp-buffer
  275.     (insert string)
  276.     (call-process-region (point-min) (point-max)
  277.              (or shell-file-name "/bin/sh")
  278.              t (current-buffer) nil
  279.              "-c" pop3-md5-program)
  280.     ;; The meaningful output is the first 32 characters.
  281.     ;; Don't return the newline that follows them!
  282.     (buffer-substring (point-min) (+ (point-min) 32))))
  283.  
  284. (defun pop3-apop (process user)
  285.   "Send alternate authentication information to the server."
  286.   (let ((pass pop3-password))
  287.     (if (and pop3-password-required (not pass))
  288.     (setq pass
  289.           (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
  290.     (if pass
  291.     (let ((hash (pop3-md5 (concat pop3-timestamp pass))))
  292.       (pop3-send-command process (format "APOP %s %s" user hash))
  293.       (let ((response (pop3-read-response process t)))
  294.         (if (not (and response (string-match "+OK" response)))
  295.         (pop3-quit process)))))
  296.     ))
  297.  
  298. ;; TRANSACTION STATE
  299.  
  300. (defun pop3-stat (process)
  301.   "Return the number of messages in the maildrop and the maildrop's size."
  302.   (pop3-send-command process "STAT")
  303.   (let ((response (pop3-read-response process t)))
  304.     (list (string-to-int (nth 1 (pop3-string-to-list response)))
  305.       (string-to-int (nth 2 (pop3-string-to-list response))))
  306.     ))
  307.  
  308. (defun pop3-list (process &optional msg)
  309.   "Scan listing of available messages.
  310. This function currently does nothing.")
  311.  
  312. (defun pop3-retr (process msg crashbuf)
  313.   "Retrieve message-id MSG to buffer CRASHBUF."
  314.   (pop3-send-command process (format "RETR %s" msg))
  315.   (pop3-read-response process)
  316.   (let ((start pop3-read-point) end)
  317.     (save-excursion
  318.       (set-buffer (process-buffer process))
  319.       (while (not (re-search-forward "^\\.\r\n" nil t))
  320.     (accept-process-output process 3)
  321.     ;; bill@att.com ... to save wear and tear on the heap
  322.     (if (> (buffer-size)  20000) (sleep-for 1))
  323.     (if (> (buffer-size)  50000) (sleep-for 1))
  324.     (if (> (buffer-size) 100000) (sleep-for 1))
  325.     (if (> (buffer-size) 200000) (sleep-for 1))
  326.     (if (> (buffer-size) 500000) (sleep-for 1))
  327.     ;; bill@att.com
  328.     (goto-char start))
  329.       (setq pop3-read-point (point-marker))
  330. ;; this code does not seem to work for some POP servers...
  331. ;; and I cannot figure out why not.
  332. ;      (goto-char (match-beginning 0))
  333. ;      (backward-char 2)
  334. ;      (if (not (looking-at "\r\n"))
  335. ;      (insert "\r\n"))
  336. ;      (re-search-forward "\\.\r\n")
  337.       (goto-char (match-beginning 0))
  338.       (setq end (point-marker))
  339.       (pop3-clean-region start end)
  340.       (pop3-munge-message-separator start end)
  341.       (save-excursion
  342.     (set-buffer crashbuf)
  343.     (erase-buffer))
  344.       (copy-to-buffer crashbuf start end)
  345.       (delete-region start end)
  346.       )))
  347.  
  348. (defun pop3-dele (process msg)
  349.   "Mark message-id MSG as deleted."
  350.   (pop3-send-command process (format "DELE %s" msg))
  351.   (pop3-read-response process))
  352.  
  353. (defun pop3-noop (process msg)
  354.   "No-operation."
  355.   (pop3-send-command process "NOOP")
  356.   (pop3-read-response process))
  357.  
  358. (defun pop3-last (process)
  359.   "Return highest accessed message-id number for the session."
  360.   (pop3-send-command process "LAST")
  361.   (let ((response (pop3-read-response process t)))
  362.     (string-to-int (nth 1 (pop3-string-to-list response)))
  363.     ))
  364.  
  365. (defun pop3-rset (process)
  366.   "Remove all delete marks from current maildrop."
  367.   (pop3-send-command process "RSET")
  368.   (pop3-read-response process))
  369.  
  370. ;; UPDATE
  371.  
  372. (defun pop3-quit (process)
  373.   "Close connection to POP3 server.
  374. Tell server to remove all messages marked as deleted, unlock the maildrop,
  375. and close the connection."
  376.   (pop3-send-command process "QUIT")
  377.   (pop3-read-response process t)
  378.   (if process
  379.       (save-excursion
  380.     (set-buffer (process-buffer process))
  381.     (goto-char (point-max))
  382.     (delete-process process))))
  383.  
  384. ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
  385.  
  386. ;;; AUTHORIZATION STATE
  387.  
  388. ;; Initial TCP connection
  389. ;; Arguments: none
  390. ;; Restrictions: none
  391. ;; Possible responses:
  392. ;;  +OK [POP3 server ready]
  393.  
  394. ;; USER name
  395. ;; Arguments: a server specific user-id (required)
  396. ;; Restrictions: authorization state [after unsuccessful USER or PASS
  397. ;; Possible responses:
  398. ;;  +OK [valid user-id]
  399. ;;  -ERR [invalid user-id]
  400.  
  401. ;; PASS string
  402. ;; Arguments: a server/user-id specific password (required)
  403. ;; Restrictions: authorization state, after successful USER
  404. ;; Possible responses:
  405. ;;  +OK [maildrop locked and ready]
  406. ;;  -ERR [invalid password]
  407. ;;  -ERR [unable to lock maildrop]
  408.  
  409. ;;; TRANSACTION STATE
  410.  
  411. ;; STAT
  412. ;; Arguments: none
  413. ;; Restrictions: transaction state
  414. ;; Possible responses:
  415. ;;  +OK nn mm [# of messages, size of maildrop]
  416.  
  417. ;; LIST [msg]
  418. ;; Arguments: a message-id (optional)
  419. ;; Restrictions: transaction state; msg must not be deleted
  420. ;; Possible responses:
  421. ;;  +OK [scan listing follows]
  422. ;;  -ERR [no such message]
  423.  
  424. ;; RETR msg
  425. ;; Arguments: a message-id (required)
  426. ;; Restrictions: transaction state; msg must not be deleted
  427. ;; Possible responses:
  428. ;;  +OK [message contents follow]
  429. ;;  -ERR [no such message]
  430.  
  431. ;; DELE msg
  432. ;; Arguments: a message-id (required)
  433. ;; Restrictions: transaction state; msg must not be deleted
  434. ;; Possible responses:
  435. ;;  +OK [message deleted]
  436. ;;  -ERR [no such message]
  437.  
  438. ;; NOOP
  439. ;; Arguments: none
  440. ;; Restrictions: transaction state
  441. ;; Possible responses:
  442. ;;  +OK
  443.  
  444. ;; LAST
  445. ;; Arguments: none
  446. ;; Restrictions: transaction state
  447. ;; Possible responses:
  448. ;;  +OK nn [highest numbered message accessed]
  449.  
  450. ;; RSET
  451. ;; Arguments: none
  452. ;; Restrictions: transaction state
  453. ;; Possible responses:
  454. ;;  +OK [all delete marks removed]
  455.  
  456. ;;; UPDATE STATE
  457.  
  458. ;; QUIT
  459. ;; Arguments: none
  460. ;; Restrictions: none
  461. ;; Possible responses:
  462. ;;  +OK [TCP connection closed]
  463.